home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _0d6f4cd51b408a71c99d0c581d25bcc0 < prev    next >
Encoding:
Text File  |  2002-05-30  |  3.6 KB  |  166 lines
  1. # Copyright (c) 1995-1999 Nick Ing-Simmons. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4. package Tk::Wm;
  5. use AutoLoader;
  6.  
  7. require Tk::Widget;
  8. *AUTOLOAD = \&Tk::Widget::AUTOLOAD;
  9.  
  10. use strict qw(vars);
  11.  
  12. # There are issues with this stuff now we have Tix's wm release/capture
  13. # as toplevel-ness is now dynamic.
  14.  
  15.  
  16. use vars qw($VERSION);
  17. $VERSION = '3.023'; # $Id: //depot/Tk8/Tk/Wm.pm#23 $
  18.  
  19. use Tk::Submethods ( 'wm' => [qw(grid tracing)] );
  20.  
  21. Direct Tk::Submethods ('wm' => [qw(aspect client colormapwindows command
  22.                        deiconify focusmodel frame geometry group
  23.                        iconbitmap iconify iconimage iconmask iconname
  24.                        iconwindow maxsize minsize overrideredirect positionfrom
  25.                        protocol resizable saveunder sizefrom state title transient
  26.                        withdraw wrapper)]);
  27.  
  28. sub SetBindtags
  29. {
  30.  my ($obj) = @_;
  31.  $obj->bindtags([ref($obj),$obj,'all']);
  32. }
  33.  
  34. sub Populate
  35. {
  36.  my ($cw,$args) = @_;
  37.  $cw->ConfigSpecs('-overanchor' => ['PASSIVE',undef,undef,undef],
  38.                   '-popanchor'  => ['PASSIVE',undef,undef,undef],
  39.                   '-popover'    => ['PASSIVE',undef,undef,undef]
  40.                  );
  41. }
  42.  
  43. sub MoveResizeWindow
  44. {
  45.  my ($w,$x,$y,$width,$height) = @_;
  46.  $w->withdraw;
  47.  $w->geometry($width.'x'.$height);
  48.  $w->MoveToplevelWindow($x,$y);
  49.  $w->deiconify;
  50. }   
  51.  
  52. sub WmDeleteWindow
  53. {
  54.  my ($w) = @_;
  55.  my $cb  = $w->protocol('WM_DELETE_WINDOW');
  56.  if (defined $cb)
  57.   {
  58.    $cb->Call;
  59.   }
  60.  else
  61.   {
  62.    $w->destroy;
  63.   }
  64. }
  65.  
  66.  
  67. 1;
  68.  
  69. __END__
  70.  
  71.  
  72. sub Post
  73. {
  74.  my ($w,$X,$Y) = @_;
  75.  $X = int($X);
  76.  $Y = int($Y);
  77.  $w->positionfrom('user');
  78.  # $w->geometry("+$X+$Y");
  79.  $w->MoveToplevelWindow($X,$Y);
  80.  $w->deiconify;
  81.  $w->raise;
  82. }
  83.  
  84. sub AnchorAdjust
  85. {
  86.  my ($anchor,$X,$Y,$w,$h) = @_;
  87.  $anchor = 'c' unless (defined $anchor);
  88.  $Y += ($anchor =~ /s/) ? $h : ($anchor =~ /n/) ? 0 : $h/2;
  89.  $X += ($anchor =~ /e/) ? $w : ($anchor =~ /w/) ? 0 : $w/2;
  90.  return ($X,$Y);
  91. }
  92.  
  93. sub Popup
  94. {
  95.  my $w = shift;
  96.  $w->configure(@_) if @_;
  97.  $w->idletasks;
  98.  my ($mw,$mh) = ($w->reqwidth,$w->reqheight);
  99.  my ($rx,$ry,$rw,$rh) = (0,0,0,0);
  100.  my $base    = $w->cget('-popover');
  101.  my $outside = 0;
  102.  if (defined $base)
  103.   {
  104.    if ($base eq 'cursor')
  105.     {
  106.      ($rx,$ry) = $w->pointerxy;
  107.     }
  108.    else
  109.     {
  110.      $rx = $base->rootx;
  111.      $ry = $base->rooty;
  112.      $rw = $base->Width;
  113.      $rh = $base->Height;
  114.     }
  115.   }
  116.  else
  117.   {
  118.    my $sc = ($w->parent) ? $w->parent->toplevel : $w;
  119.    $rx = -$sc->vrootx;
  120.    $ry = -$sc->vrooty;
  121.    $rw = $w->screenwidth;
  122.    $rh = $w->screenheight;
  123.   }
  124.  my ($X,$Y) = AnchorAdjust($w->cget('-overanchor'),$rx,$ry,$rw,$rh);
  125.  ($X,$Y)    = AnchorAdjust($w->cget('-popanchor'),$X,$Y,-$mw,-$mh);
  126.  $w->Post($X,$Y); 
  127.  $w->waitVisibility;
  128. }
  129.  
  130. sub FullScreen
  131. {
  132.  my $w = shift;
  133.  my $over = (@_) ? shift : 0;
  134.  my $width  = $w->screenwidth;
  135.  my $height = $w->screenheight;
  136.  $w->GeometryRequest($width,$height);
  137.  $w->overrideredirect($over & 1);
  138.  $w->Post(0,0);
  139.  $w->update;
  140.  if ($over & 2)
  141.   {
  142.    my $x = $w->rootx;
  143.    my $y = $w->rooty;
  144.    $width -= 2*$x;
  145.    $height -= $x + $y;
  146.    $w->GeometryRequest($width,$height);
  147.    $w->update;
  148.   }
  149. }
  150.  
  151. sub iconposition
  152. {
  153.  my $w = shift;
  154.  if (@_ == 1)
  155.   {
  156.    return $w->wm('iconposition',$1,$2) if $_[0] =~ /^(\d+),(\d+)$/;
  157.    if ($_[0] =~ /^([+-])(\d+)([+-])(\d+)$/)
  158.     {
  159.      my $x = ($1 eq '-') ? $w->screenwidth-$2 : $2;
  160.      my $y = ($3 eq '-') ? $w->screenheight-$4 : $4;
  161.      return $w->wm('iconposition',$x,$y);
  162.     }
  163.   }
  164.  $w->wm('iconposition',@_);
  165. }
  166.